home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 November: Tool Chest / Dev.CD Nov 94.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Matts-utils.sea / Matts-utils / object-FDI-drop-glue.lisp / object-FDI-drop-glue.lisp
Encoding:
Text File  |  1992-08-15  |  4.6 KB  |  121 lines  |  [TEXT/CCL2]
  1. ;;;
  2. ;;; object-FDI-drop-glue.lisp
  3. ;;;
  4.  
  5. #|
  6. ================================================================
  7. Purpose ========================================================
  8. ================================================================
  9. Tell object-fred-dialog-items how to start drops. Since
  10. object-fred-dialog-item is a subclass of fred-dialog-item they already know
  11. how to receive drops via the code at the bottom of
  12. object-fred-dialog-item.lisp .
  13.  
  14.  
  15. ================================================================
  16. Status =========================================================
  17. ================================================================
  18. In-progress.
  19.  
  20.  
  21. ================================================================
  22. Change history =================================================
  23. ================================================================
  24. 15-Aug-92 mc    Created.
  25.  
  26. |#
  27.  
  28.  
  29. (in-package "CCL")
  30.  
  31. (require "OBJECT-DROPPER" "CCL:UMASS Utils;object-dropper")
  32. (require "OBJECT-FRED-DIALOG-ITEM" "CCL:UMASS Utils;object-fred-dialog-item")
  33.  
  34.  
  35. ;;;================================================================
  36. ;;; Tell object-fred-dialog-items how to start and receive drops.
  37. ;;;================================================================
  38.  
  39. (defmethod receive-drop ((view object-fred-dialog-item)
  40.                          (object t)
  41.                          (pt-global integer))
  42.   ;;
  43.   (add-link view object
  44.             (fred-point-position view (global-to-local view pt-global))))
  45.  
  46.  
  47. (defmethod macptr-region-global ((view object-fred-dialog-item)
  48.                                  (object t)
  49.                                  (pt-global-starting integer))
  50.   "Returns a rectangular region that matches view's current selection."
  51.   (declare (optimize speed)
  52.            (ignore object pt-global-starting))
  53.   ;;
  54.   (multiple-value-bind (int-index-selection-start int-index-selection-end)
  55.                        (selection-range view)
  56.     (if (= int-index-selection-start int-index-selection-end)
  57.       (call-next-method)                ;better choice?
  58.       
  59.       #|;; How to get the selection as a region? Following didn't work:
  60.         ;; Tricky "catching" of the drawing of the selection.
  61.       (let* ((macptr-region-global (#_NewRgn)))
  62.         (#_OpenRgn)
  63.         (set-selection-range view int-index-selection-start int-index-selection-end)
  64.         (fred-update view)
  65.         (#_CloseRgn macptr-region-global)
  66.         macptr-region-global)|#
  67.       
  68.       ;; Return a rectangular region of fixed witdth at the selection's
  69.       ;;  start.
  70.       (let* ((macptr-region-global (#_NewRgn))
  71.              (int-pos-horizontal-bottom-start (fred-hpos view int-index-selection-start))
  72.              (int-pos-vertical-start (fred-vpos view int-index-selection-start))
  73.              (int-height-line (- (fred-line-vpos view 1)
  74.                                  (fred-line-vpos view 0)))
  75.              (int-left int-pos-horizontal-bottom-start)
  76.              (int-right (+ int-left 20))
  77.              (int-bottom int-pos-vertical-start)
  78.              (int-top (- int-bottom int-height-line))
  79.              (pt-top-left (local-to-global view (view-position view))))
  80.         (rlet ((rect :rect :left int-left :top int-top :right int-right
  81.                      :bottom int-bottom))
  82.           (#_RectRgn macptr-region-global rect)
  83.           (#_OffsetRgn macptr-region-global (point-h pt-top-left)
  84.            (point-v pt-top-left))
  85.           macptr-region-global)))))
  86.  
  87.  
  88. ;;; Done.
  89.  
  90. (provide "OBJECT-FDI-DROP-GLUE")
  91.  
  92.  
  93. #|
  94. ;;;
  95. ;;; Now call evaluate the test code at the bottom of
  96. ;;;  "object-fred-dialog-item.lisp", eval (test-ofdi) and (test-dropper)
  97. ;;;  and drag away. You can use the following:
  98. ;;;
  99. ;;; Drag starters: "Test Dropper"'s "Start Tracking" button
  100. ;;;            Any selection in "Test OFDI" window
  101. ;;;
  102. ;;; Drag receivers: "Test Dropper"'s "Describe" button
  103. ;;;            "Test OFDI" window
  104. ;;;
  105.  
  106. (defmethod view-click-event-handler ((describing-ofdi describing-ofdi)
  107.                                      where)
  108.   "Implements this dragging policy: if where is in describing-ofdi's
  109. selection range then calls track-mouse-for-dropping."
  110.   ;;
  111.   (let* ((int-index (fred-point-position describing-ofdi where)))
  112.     (multiple-value-bind (int-index-selection-start int-index-selection-end)
  113.                          (selection-range describing-ofdi)
  114.       (if (and (/= int-index-selection-start int-index-selection-end)
  115.                (<= int-index-selection-start int-index int-index-selection-end))
  116.         (track-mouse-for-dropping
  117.          describing-ofdi
  118.          (first (l-str-obj-ofdi-selected describing-ofdi))
  119.          (local-to-global (view-container view) where))
  120.         (call-next-method)))))
  121. |#